#lang racket


(require mysterx)

(require "../backends/main.rkt")

(provide load-rhino-com
         
         ; constants
         optional
         
         create-preview-image-honor-flag
         create-preview-image-draw-flag
         create-preview-image-ghosted-flag
         
         view-display-mode-wireframe
         view-display-mode-shaded
         view-display-mode-render-preview
         
         view-perspective
         
         view-projection-mode-parallel
         view-projection-mode-perspective
         
         ; methods
         add-arc
         add-box
         add-circle
         add-cone
         add-cylinder
         add-edge-srf
         add-ellipse
         add-hatch
         add-interp-curve
         add-line
         add-loft-surface
         all-objects
         add-planar-srf
         add-plane-surface
         add-point
         add-polyline
         add-sphere
         add-srf-pt
         
         boolean-difference
         boolean-intersection
         boolean-union
         
         bounding-box
         
         cap-planar-holes
         close-curve
         
         command
         
         copy-object
         copy-objects
         
         create-preview-image
         
         create-solid
         
         delete-object
         delete-objects
         
         duplicate-edge-curves
         duplicate-surface-border
         
         enable-redraw
         
         extrude-curve
         extrude-curve-point
         extrude-curve-straight
         extrude-surface
         
         get-object
         intersect-breps
         
         last-created-objects
         
         join-curves
         join-surfaces
         
         move-object
         move-objects
         offset-surface
         rotate-object
         rotate-objects
         scale-object
         scale-objects
         select-object
         select-objects
         surface-surface-intersection
         
         unselect-all-objects
         unselect-object
         unselect-objects
         
         view-camera-lens
         view-camera-target
         view-cplane
         view-display-mode
         view-projection
         view-radius
         view-size
         
         world-xy-plane
         world-yz-plane
         world-zx-plane
         
         ; circle properties
         is-circle?
         circle-center-point
         circle-radius
         circle-normal
         
         ; curve properties
         is-curve?
         is-curve-closable?
         is-curve-closed?
         curve-end-point
         curve-normal
         curve-start-point
         
         ; object properties
         is-object?
         
         ; polycurve properties
         is-polycurve?
         
         ; polysurface properties
         is-polysurface?
         
         ; surface properties
         is-surface?
         surface-curvature
         surface-domain)


; exception

(define-struct (com-exn exn:fail) ())

(define (raise-com-exn msg)
  (raise (make-com-exn msg (current-continuation-marks))))


; constants

(define create-preview-image-honor-flag 1)
(define create-preview-image-draw-flag 2)
(define create-preview-image-ghosted-flag 4)

(define optional com-omit)

(define view-display-mode-wireframe 0)
(define view-display-mode-shaded 1)
(define view-display-mode-render-preview 2)

(define view-perspective "Perspective")

(define view-projection-mode-parallel 1)
(define view-projection-mode-perspective 2)


; load

(define rhino-com-msg "Waiting for Rhinoceros3D to be ready...")

(define (rhino-invoke name . args)
  (apply com-invoke rhino-coobject name args))

(define (rhino-check-invoke name . args)
  (let ((val (apply rhino-invoke name args)))
    (if (void? val)
        (raise-com-exn (format "~A: ~A" name args))
        val)))

(define (rhino-get-property . args)
  (apply com-get-property args))

(define (rhino-set-property! . args)
  (apply com-set-property! args))


(define rhino-coclass #f)
(define rhino-coobject #f)


(define (load-rhino-com)
  (set! rhino-coclass
        (let ((coclass-name "Rhino4.Interface"))
          (with-handlers ((exn?
                           (λ (e)
                             (displayln "Starting Rhinoceros 3D...")
                             (cci/coclass coclass-name))))
            (gao/coclass coclass-name))))
  (rhino-set-property! rhino-coclass "Visible" true)
  ; edit: make better
  (set! rhino-coobject
        (try-void-connection
         rhino-com-msg
         (λ () (com-invoke rhino-coclass "GetScriptObject")))))


; methods

(define (add-arc plane radius angle)
  (rhino-check-invoke "AddArc" plane radius angle))

(define (add-box corners)
  (rhino-check-invoke "AddBox" corners))

(define (add-circle plane radius)
  (rhino-check-invoke "AddCircle" plane radius))

(define (add-edge-srf objects)
  (rhino-check-invoke "AddEdgeSrf" objects))

(define (add-cone base height radius cap)
  (rhino-check-invoke "AddCone" base height radius cap))

(define (add-ellipse plane x-radius y-radius)
  (rhino-check-invoke "AddEllipse" plane x-radius y-radius))

(define (add-hatch curve (hatch com-omit) (scale com-omit) (rotation com-omit))
  (rhino-check-invoke "AddHatch" curve hatch scale rotation))

(define (add-interp-curve points)
  (rhino-check-invoke "AddInterpCurve" points 3))

(define (add-cylinder base height radius cap)
  (rhino-check-invoke "AddCylinder" base height radius cap))

(define (add-line start end)
  (rhino-check-invoke "AddLine" start end))

(define add-loft-surface
  (case-lambda
    ((objects)
     (rhino-check-invoke "AddLoftSrf" objects))
    ((objects closed)
     (rhino-check-invoke "AddLoftSrf" objects com-omit com-omit com-omit com-omit com-omit closed))
    ((objects start end type style value closed)
     (rhino-check-invoke "AddLoftSrf" objects start end type style value closed))))

(define (all-objects . args)
  (with-handlers ((com-exn? (λ (e) (vector))))
    (match args
      ((list) (rhino-check-invoke "AllObjects"))
      ((list select?) (rhino-check-invoke "AllObjects" select?))
      ((list select? include-lights?) (rhino-check-invoke "AllObjects" select? include-lights?))
      ((list select? include-lights? include-grips?) (rhino-check-invoke "AllObjects" select? include-lights? include-grips?)))))

(define (add-planar-srf objects)
  (rhino-check-invoke "AddPlanarSrf" objects))

(define (add-plane-surface plane du dv)
  (rhino-check-invoke "AddPlaneSurface" plane du dv))

(define (add-point point)
  (rhino-check-invoke "AddPoint" point))  

(define (add-polyline points)
  (rhino-check-invoke "AddPolyline" points))

(define (add-sphere center radius)
  (rhino-check-invoke "AddSphere" center radius))

(define (add-srf-pt points)
  (rhino-check-invoke "AddSrfPt" points))

(define (boolean-difference objects1 objects2 delete)
  (com-invoke rhino-coobject "BooleanDifference" objects1 objects2 delete))

(define (boolean-intersection objects1 objects2 delete)
  (com-invoke rhino-coobject "BooleanIntersection" objects1 objects2 delete))

(define (boolean-union objects delete)
  (com-invoke rhino-coobject "BooleanUnion" objects delete))

(define (bounding-box objects)
  (rhino-check-invoke "BoundingBox" objects))

(define (cap-planar-holes surface)
  (rhino-check-invoke "CapPlanarHoles" surface))

(define close-curve
  (case-lambda
    ((object)
     (rhino-check-invoke "CloseCurve" object))
    ((object tolerance)
     (rhino-check-invoke "CloseCurve" object tolerance))))

(define (command command (echo? #t))
  (rhino-check-invoke "Command" command echo?))

(define (copy-object object)
  (rhino-check-invoke "CopyObject" object))

(define (copy-objects objects)
  (rhino-check-invoke "CopyObjects" objects))

(define create-preview-image
  (case-lambda
    ((file) (rhino-invoke "CreatePreviewImage" file))
    ((file view) (rhino-invoke "CreatePreviewImage" file view))
    ((file view size) (rhino-invoke "CreatePreviewImage" file view size))
    ((file view size flags) (rhino-invoke "CreatePreviewImage" file view size flags))
    ((file view size flags wireframe?) (rhino-invoke "CreatePreviewImage"  file view size flags wireframe?))))

(define (create-solid objects delete?)
  (rhino-check-invoke "CreateSolid" objects delete?))

(define (delete-object object)
  (rhino-check-invoke "DeleteObject" object))

(define (delete-objects object)
  (rhino-check-invoke "DeleteObjects" object))

(define (duplicate-edge-curves object select?)
  (rhino-check-invoke "DuplicateEdgeCurves" object select?))

(define (duplicate-surface-border object)
  (rhino-check-invoke "DuplicateSurfaceBorder" object))

(define (enable-redraw redraw)
  (rhino-invoke "EnableRedraw" redraw))

(define (extrude-curve curve path)
  (rhino-check-invoke "ExtrudeCurve" curve path))

(define (extrude-curve-point curve point)
  (rhino-check-invoke "ExtrudeCurvePoint" curve point))

(define (extrude-curve-straight curve start-point end-point)
  (rhino-check-invoke "ExtrudeCurveStraight" curve start-point end-point))

(define (extrude-surface surface curve cap?)
  (rhino-check-invoke "ExtrudeSurface" surface curve cap?))

(define (get-object str kind)
  (rhino-check-invoke "GetObject" str kind))

(define (intersect-breps brep1 brep2 (tolerance com-omit))
  (rhino-check-invoke "IntersectBreps" brep1 brep2 tolerance))

; edit: create an enum for flags
(define (last-created-objects (select? #f) (flags 0))
  (rhino-check-invoke "LastCreatedObjects" select? flags))

(define (join-curves objects delete?)
  (rhino-check-invoke "JoinCurves" objects delete?))

(define (join-surfaces objects delete?)
  (rhino-check-invoke "JoinSurfaces" objects delete?))

(define (move-object object translation)
  (rhino-check-invoke "MoveObject" object translation))

(define move-objects
  (case-lambda
    ((objects start end)
     (rhino-check-invoke "MoveObjects" objects start end))
    ((objects translation)
     (rhino-check-invoke "MoveObjects" objects translation))))

(define (offset-surface object distance)
  (rhino-check-invoke "OffsetSurface" object distance))

(define (rotate-object object point angle axis copy)
  (rhino-check-invoke "RotateObject" object point angle axis copy))

(define (rotate-objects objects point angle axis copy)
  (rhino-check-invoke "RotateObjects" objects point angle axis copy))

(define (scale-object object origin scale copy)
  (rhino-check-invoke "ScaleObject" object origin scale copy))

(define (scale-objects objects origin scale copy)
  (rhino-check-invoke "ScaleObjects" objects origin scale copy))

(define (select-object object)
  (rhino-check-invoke "SelectObject" object))

(define (select-objects objects)
  (rhino-check-invoke "SelectObjects" objects))

(define (surface-surface-intersection surface-a surface-b (tolerance com-omit) (create? com-omit))
  (rhino-check-invoke "SurfaceSurfaceIntersection" surface-a surface-b tolerance create?))

(define (unselect-all-objects)
  (rhino-invoke "UnselectAllObjects"))

(define (unselect-object object)
  (rhino-check-invoke "UnselectObject" object))

(define (unselect-objects objects)
  (rhino-check-invoke "UnselectObjects" objects))

(define view-camera-lens
  (case-lambda
    (() (rhino-check-invoke "ViewCameraLens"))
    ((view) (rhino-check-invoke "ViewCameraLens" view))
    ((view length) (rhino-check-invoke "ViewCameraLens" view length))))

(define view-camera-target
  (case-lambda
    (() (rhino-check-invoke "ViewCameraTarget"))
    ((view) (rhino-check-invoke "ViewCameraTarget" view))
    ((view camera) (rhino-check-invoke "ViewCameraTarget" view camera))
    ((view camera target) (rhino-check-invoke "ViewCameraTarget" view camera target))))

(define (view-cplane)
  (error 'view-cplane "Not implemented"))

(define view-display-mode
  (case-lambda
    (() (rhino-check-invoke "ViewDisplayMode"))
    ((view) (rhino-check-invoke "ViewDisplayMode" view))
    ((view mode) (rhino-check-invoke "ViewDisplayMode" view mode))))

(define view-projection
  (case-lambda
    (() (rhino-check-invoke "ViewProjection"))
    ((view) (rhino-check-invoke "ViewProjection" view))
    ((view mode) (rhino-check-invoke "ViewProjection" view mode))))

(define view-radius
  (case-lambda
    (() (rhino-check-invoke "ViewRadius"))
    ((view) (rhino-check-invoke "ViewRadius" view))
    ((view radius) (rhino-check-invoke "ViewRadius" view radius))))

(define (view-size)
  (case-lambda
    (() (rhino-check-invoke "ViewSize"))
    ((view) (rhino-check-invoke "ViewSize" view))))

(define (world-xy-plane)
  (rhino-invoke "WorldXYPlane"))

(define (world-yz-plane)
  (rhino-invoke "WorldYZPlane"))

(define (world-zx-plane)
  (rhino-invoke "WorldZXPlane"))


; circle properties

(define (is-circle? object)
  (rhino-check-invoke "IsCircle" object))

(define (circle-center-point object)
  (rhino-check-invoke "CircleCenterPoint" object))

(define (circle-radius object)
  (rhino-check-invoke "CircleRadius" object))

(define (circle-normal object)
  (curve-normal object))


; curve properties

(define (is-curve? object)
  (rhino-check-invoke "IsCurve" object))

(define (is-curve-closed? object)
  (rhino-check-invoke "IsCurveClosed" object))

(define is-curve-closable?
  (case-lambda
    ((object)
     (rhino-check-invoke "IsCurveClosable" object))
    ((object tolerance)
     (rhino-check-invoke "IsCurveClosable" object tolerance))))

(define (curve-end-point object)
  (rhino-check-invoke "CurveEndPoint" object))

(define (curve-normal object)
  (rhino-check-invoke "CurveNormal" object))

(define (curve-start-point object)
  (rhino-check-invoke "CurveStartPoint" object))


; object properties

(define (is-object? object)
  (rhino-invoke "IsObject" object))


; polycurve properties

(define (is-polycurve? object)
  (rhino-check-invoke "IsPolyCurve" object))


; polysurface properties

(define (is-polysurface? object)
  (rhino-check-invoke "IsPolysurface" object))


; surface properties

(define (is-surface? object)
  (rhino-check-invoke "IsSurface" object))

(define (surface-domain object domain)
  (rhino-check-invoke "SurfaceDomain" object domain))

(define (surface-curvature object uv)
  (rhino-check-invoke "SurfaceCurvature" object uv))